Gold Medal Software 1/Gold Medal Software Volume 1 (Gold Medal) (1994).iso/prog/tpwprog7.arj/SYSCOLOR.PAS

Pascal/Delphi Source File | 1992-07-02 | 16.4 KB | 605 lines

{ syscolor.pas -- Set system colors }

program SysColor;

{$R syscolor.res }

uses WinTypes, WinProcs, WObjects, Strings;

const

  app_Name  = 'SysColor';       { Application name }
  ini_FName = 'SYSCOLOR.INI';   { .INI file name }

  id_Menu      = 100;           { Menu resource ID }
  id_Icon      = 200;           { Icon resource ID }
  cm_About     = 101;           { Menu:About command resource ID }
  cm_Quit      = 102;           { Menu:Exit command resource ID }
  id_SBarRed   = 100;           { Window control IDs }
  id_SBarGrn   = 101;
  id_SBarBlu   = 102;
  id_SetBtn    = 103;
  id_ResetBtn  = 104;
  id_SaveBtn   = 105;
  id_QuitBtn   = 106;

  RedMask = $000000FF;          { Color value extraction masks }
  GrnMask = $0000FF00;
  BluMask = $00FF0000;

  nonStop: Boolean = false;     { Use switches: -s = false; -n = true }

type

  SCApplication = object(TApplication)
    constructor Init(AName: PChar);
    procedure InitMainWindow; virtual;
  end;

  PColorScrollBar = ^TColorScrollBar;
  TColorScrollBar = object(TScrollBar)
    Digits: PStatic;
    constructor Init(AParent: PWindowsObject; AnID, Y: Integer;
      ALabel: PChar; var SText: PStatic);
    procedure SetupWindow; virtual;
    procedure DefNotificationProc(var Msg: TMessage); virtual;
    procedure SetDigits;
    procedure SetPosition(ThumbPos: Integer); virtual;
  end;

  PSCWindow = ^SCWindow;
  SCWindow = object(TWindow)
  {- Data fields }
    Dc: Hdc;
    ButtonDown, Changed: Boolean;
    LineX1, LineY1, LineX2, LineY2: Integer;
    ArrowCursor, CrossHairCursor: HCursor;
    SBarRed, SBarGrn, SBarBlu: PColorScrollBar;
    STxtRed, STxtGrn, STxtBlu: PStatic;
    SampleRect: TRect;
    SampleColor: TColorRef;
    DraggingOrigin: Integer;
  {- Methods }
    constructor Init(AParent: PWindowsObject; ATitle: PChar);
    destructor Done; virtual;
    procedure SetupWindow; virtual;
    procedure InitChildControls;
    procedure ResetSystemColors;
    procedure SynchronizeScrollBars;
    procedure DrawRubberband;
    function CanClose: Boolean; virtual;
    procedure GetWindowClass(var AWndClass: TWndClass); virtual;
    procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
    function InsideColorRect(X, Y: Integer; var Index: Integer): Boolean;
    procedure CMAbout(var Msg: TMessage);
      virtual cm_First + cm_About;
    procedure CMQuit(var Msg: TMessage);
      virtual cm_First + cm_Quit;
    procedure WMHScroll(var Msg: TMessage);
      virtual wm_First + wm_HScroll;
    procedure WMLButtonDown(var Msg: TMessage);
      virtual wm_First + wm_LButtonDown;
    procedure WMLButtonUp(var Msg: TMessage);
      virtual wm_First + wm_LButtonUp;
    procedure WMMouseMove(var Msg: TMessage);
      virtual wm_First + wm_MouseMove;
    procedure SaveBtnEvent(var Msg: TMessage);
      virtual id_First + id_SaveBtn;
    procedure SetBtnEvent(var Msg: TMessage);
      virtual id_First + id_SetBtn;
    procedure QuitBtnEvent(var Msg: TMessage);
      virtual id_First + id_QuitBtn;
    procedure ResetBtnEvent(var Msg: TMessage);
      virtual id_First + id_ResetBtn;
  end;

  SysColorRec = record
    OriginalColor: TColorRef;  { Color on starting program }
    CurrentColor: TColorRef;   { New color selected by user }
    SCRect: TRect;             { Location of system-color rectangle }
  end;

var

  SysColorArray: Array[0 .. color_EndColors] of SysColorRec;
  SysColorNames: Array[0 .. color_EndColors] of PChar;


{ Common routines }

{- Convert integer N to C char array. If Max > 0, pad with 0s. }
procedure Int2Str(N, Max: Integer; C: PChar);
var
  S: String[6];
begin
  Str(N, S);
  while Length(S) < Max do S := '0' + S;
  StrPCopy(C, S)
end;

{- Prepare global SysColorArray with current color values }
procedure InitSysColorArray;
var
  I: Integer;
begin
  for I := 0 to color_EndColors do with SysColorArray[I] do
  begin
    OriginalColor := GetSysColor(I);
    CurrentColor := OriginalColor;
    with SCRect do
    begin
      Left := 500;
      Top := 20 + (I * 20);
      Right := 600;
      Bottom := Top + 15
    end
  end
end;

{- Change system colors to values in SysColorArray }
procedure ChangeSystemColors;
var
  I: Integer;
  InxArray: Array[0 .. color_EndColors] of Integer;
  ClrArray: Array[0 .. color_EndColors] of TColorRef;
begin
  for I := 0 to color_EndColors do
  begin
    InxArray[I] := I;
    ClrArray[I] := SysColorArray[I].CurrentColor
  end;
  SetSysColors(color_EndColors + 1, InxArray[0], ClrArray[0])
end;

{- Save colors to SYSCOLOR.INI in Windows directory }
function SaveSettings: Boolean;
var
  I: Integer;
  S: String[12];
  NewValue: array[0 .. 12] of Char;
begin
  SaveSettings := true;  { Think positively! }
  for I := 0 to color_EndColors do with SysColorArray[I] do
  begin
    Str(CurrentColor, S);
    StrPCopy(NewValue, S);
    if not WritePrivateProfileString(app_Name, SysColorNames[I],
      NewValue, ini_FName) then
    begin
      SaveSettings := false;
      Exit
    end
  end
end;

{- Load colors from SYSCOLOR.INI if present }
procedure LoadSettings;
var
  I, Err: Integer;
  S: String[12];
  DefaultValue, NewValue: array[0 .. 12] of Char;
begin
  for I := 0 to color_EndColors do with SysColorArray[I] do
  begin
    Str(CurrentColor, S);
    StrPCopy(DefaultValue, S);
    GetPrivateProfileString(app_Name, SysColorNames[I],
      DefaultValue, NewValue, sizeof(NewValue), ini_FName);
    S := StrPas(NewValue);
    Val(S, CurrentColor, Err);
    if Err <> 0 then CurrentColor := OriginalColor
  end;
  GetPrivateProfileString(app_Name, 'nonstop',
    'false', NewValue, sizeof(NewValue), ini_FName);
  if StrComp('false', NewValue) <> 0
    then nonStop := true
end;

{- Get command-line switches }
procedure GetSwitches;
var
  I: Integer;
  S: String[128];
  C: Char;
begin
  for I := 1 to ParamCount do
  begin
    S := ParamStr(I);
    C := upcase(S[1]);
    if (Length(S) > 1) and ((C = '-') or (C = '/')) then
    case upcase(S[2]) of
      'N' : nonStop := true;
      'S' : nonStop := false
    end
  end
end;


{ SCApplication }

{- Construct SCApplication object }
constructor SCApplication.Init(AName: PChar);
begin
  TApplication.Init(AName);
  InitSysColorArray;          { Initialize colors }
  LoadSettings;               { Load .INI settings if present }
  GetSwitches;                { Get command-line switches }
  if nonStop then
  begin                       { Optional nonstop operation: }
    ChangeSystemColors;       { Change colors to .INI settings }
    MainWindow^.CloseWindow   { Exit application }
  end;
end;

{- Initialize application's window }
procedure SCApplication.InitMainWindow;
begin
  MainWindow := New(PSCWindow, Init(nil, 'Set System Colors'))
end;


{ TColorScrollBar }

{- Construct TColorScrollBar instance }
constructor TColorScrollBar.Init(AParent: PWindowsObject;
  AnID, Y: Integer; ALabel: PChar; var SText: PStatic);
begin
  TScrollBar.Init(AParent, AnID, 50, Y, 250, 18, true);
  New(SText, Init(AParent, -1, ALabel, 5, Y, 40, 18, 40));
  New(Digits, Init(AParent, -1, '000', 310, Y, 40, 18, 3));
  SText := Digits  { Return pointer to control's digital "readout" }
end;

{- Set scroll bar range for a byte color value }
procedure TColorScrollBar.SetupWindow;
begin
  TScrollBar.SetupWindow;
  SetRange(0, 255)
end;

{- Change digital readout for changes to scroll bar position }
procedure TColorScrollBar.DefNotificationProc(var Msg: TMessage);
begin
  SetDigits;
  TScrollBar.DefNotificationProc(Msg)
end;

{- Change digital readout to match current position }
procedure TColorScrollBar.SetDigits;
var
  C: array[0 .. 3] of Char;
begin
  Int2Str(GetPosition, 3, C);
  Digits^.SetText(C)
end;

{- Force scroll bar to specific position }
procedure TColorScrollBar.SetPosition(ThumbPos: Integer);
begin
  TScrollBar.SetPosition(ThumbPos);
  SetDigits
end;


{ SCWindow }

{- Construct SCWindow object and instantiate child windows }
constructor SCWindow.Init(AParent: PWindowsObject; ATitle: PChar);
begin
  TWindow.Init(AParent, ATitle);
  EnableKBHandler;
  Attr.Menu := LoadMenu(HInstance, PChar(id_Menu));
  with Attr do
  begin
    X := 10; Y := 10; H := 460; W := 615
  end;
  ButtonDown := false;
  Changed := false;
  ArrowCursor := LoadCursor(0, idc_Arrow);
  CrossHairCursor := LoadCursor(0, idc_Cross);
  SampleColor := 0;
  with SampleRect do
  begin
    Left := 200; Top := 150; Right := 300; Bottom := 230;
  end;
  InitChildControls
end;

{- Finish window preparation }
procedure SCWindow.SetupWindow;
var
  I: Integer;
  Buffer: array[0 .. 40] of Char;
begin
  TWindow.SetupWindow;
  SetFocus(ChildList^.HWindow);
  for I := 0 to color_EndColors do
  begin
    LoadString(HInstance, I, Buffer, 40);
    SysColorNames[I] := StrNew(Buffer)
  end
end;

{- Destroy SCWindow instance }
destructor SCWindow.Done;
var
  I: Integer;
begin
  for I := 0 to color_EndColors do
    StrDispose(SysColorNames[I]);
  TWindow.Done
end;

{- Create and initialize child controls in window }
procedure SCWindow.InitChildControls;
var
  AControl: PControl;  { Throw-away control pointer }
begin
  SBarRed := New(PColorScrollBar, Init(@Self, id_SBarRed, 20,
    'Red', STxtRed));
  SBarGrn := New(PColorScrollBar, Init(@Self, id_SBarGrn, 60,
    'Green', STxtGrn));
  SBarBlu := New(PColorScrollBar, Init(@Self, id_SBarBlu, 100,
    'Blue', STxtBlu));
  AControl    := New(PButton, Init(@Self, id_SetBtn,
    'Se&t',   50, 150, 80, 40, false));
  AControl    := New(PButton, Init(@Self, id_ResetBtn,
    '&Reset', 50, 210, 80, 40, false));
  AControl    := New(PButton, Init(@Self, id_SaveBtn,
    '&Save',  50, 270, 80, 40, false));
  AControl    := New(PButton, Init(@Self, id_QuitBtn,
    '&Quit',  50, 330, 80, 40, true))
end;

{- Return true if window may close }
function SCWindow.CanClose: Boolean;
var
  Answer: Integer;
begin
  CanClose := true;
  if Changed then
  begin
    Answer := MessageBox(HWindow, 'Save colors before quitting?',
      'Please answer', mb_YesNoCancel or mb_IconQuestion);
    if Answer = idYes then
      CanClose := SaveSettings
    else if Answer = idCancel then
      CanClose := false
  end
end;

{- Reset system colors to values saved at start of program }
procedure SCWindow.ResetSystemColors;
var
  I: Integer;
begin
  for I := 0 to color_EndColors do with SysColorArray[I] do
    CurrentColor := OriginalColor;
  Changed := false
end;

{- Modify window class to use custom icon }
procedure SCWindow.GetWindowClass(var AWndClass: TWndClass);
begin
  TWindow.GetWindowClass(AWndClass);
  AWndClass.hIcon := LoadIcon(HInstance, PChar(id_Icon))
end;

{- Adjust scroll bars to match SampleColor }
procedure SCWindow.SynchronizeScrollBars;
var
  DummyMsg: TMessage;
begin
  SBarRed^.SetPosition(SampleColor and RedMask);
  SBarGrn^.SetPosition((SampleColor and GrnMask) shr 8);
  SBarBlu^.SetPosition((SampleColor and BluMask) shr 16);
  WMHScroll(DummyMsg)  { Force scroll bar update }
end;

{- Display "About program" dialog box }
procedure SCWindow.CMAbout(var Msg: TMessage);
var
  Dialog: TDialog;
begin
  Dialog.Init(@Self, 'About');
  Dialog.Execute;
  Dialog.Done
end;

{- Execute Menu:Exit command }
procedure SCWindow.CMQuit(var Msg: TMessage);
begin
  CloseWindow
end;

{- Draw rubberband connecting line while dragging colors }
procedure SCWindow.DrawRubberband;
begin
  MoveTo(Dc, LineX1, LineY1);
  LineTo(Dc, LineX2, LineY2)
end;

{- Return true if point X, Y is inside a color rectangle }
function SCWindow.InsideColorRect(X, Y: Integer;
  var Index: Integer): Boolean;
var
  CursorLocation: TPoint;
  I: Integer;
begin
  CursorLocation.X := X;
  CursorLocation.Y := Y;
  InsideColorRect := true;
  if PtInRect(SampleRect, CursorLocation) then
  begin
    Index := -1;      { Inside sample color box }
    Exit
  end else
  for I := 0 to color_EndColors do
    if PtInRect(SysColorArray[I].SCRect, CursorLocation) then
    begin
      Index := I;     { Inside a system color rectangle }
      Exit
    end;
  InsideColorRect := false
end;

{- Change color rectangle when a scroll bar moves }
procedure SCWindow.WMHScroll(var Msg: TMessage);
begin
  TWindow.WMHScroll(Msg);
  SampleColor := RGB(SBarRed^.GetPosition, SBarGrn^.GetPosition,
    SBarBlu^.GetPosition);
  InvalidateRect(HWindow, @SampleRect, False)
end;

{- Handle left-button down event }
procedure SCWindow.WMLButtonDown(var Msg: TMessage);
begin
  if not ButtonDown then with Msg do
  if InsideColorRect(LParamLo, LParamHi, DraggingOrigin) then
  begin
    Dc := GetDC(HWindow);
    LineX1 := LParamLo;
    LineY1 := LParamHi;
    LineX2 := LineX1;
    LineY2 := LineY1;
    SetROP2(Dc, r2_Not);
    DrawRubberband;
    ButtonDown := true;
    SetCursor(CrossHairCursor);
    SetCapture(HWindow);
    if DraggingOrigin >= 0 then {- Clicked in a system color rect }
    begin
      SampleColor := SysColorArray[DraggingOrigin].CurrentColor;
      SynchronizeScrollBars
    end
  end
end;

{- Handle left-button up event }
procedure SCWindow.WMLButtonUp(var Msg: TMessage);
var
  Index: Integer;
  NewColor: TColorRef;
begin
  if ButtonDown then with Msg do
  begin
    if InsideColorRect(LParamLo, LParamHi, Index) then
    if (Index <> DraggingOrigin) and (Index >= 0) then
    begin
      Changed := true;
      if DraggingOrigin >= 0
        then NewColor := SysColorArray[DraggingOrigin].CurrentColor
        else NewColor := SampleColor;
      SysColorArray[Index].CurrentColor := NewColor;
      InvalidateRect(HWindow, nil, False)
    end;
    DrawRubberband;         { Erase last line }
    SetROP2(Dc, r2_Black);
    ButtonDown := false;
    SetCursor(ArrowCursor);
    ReleaseDC(HWindow, Dc);
    ReleaseCapture
  end
end;

{- Handle mouse-move event }
procedure SCWindow.WMMouseMove(var Msg: TMessage);
begin
  if ButtonDown then
  begin
    DrawRubberband;         { Erase old line }
    with Msg do
    begin
      LineX2 := LParamLo;
      LineY2 := LParamHi;
      DrawRubberband        { Draw new line }
    end
  end
end;

{- Respond to Set button selection }
procedure SCWindow.SetBtnEvent(var Msg: TMessage);
begin
  ChangeSystemColors
end;

{- Respond to Reset button selection }
procedure SCWindow.ResetBtnEvent(var Msg: TMessage);
begin
  ResetSystemColors;
  ChangeSystemColors
end;

{- Respond to Save button selection }
procedure SCWindow.SaveBtnEvent(var Msg: TMessage);
begin
  if SaveSettings then Changed := false
end;

{- Respond to Quit button selection }
procedure SCWindow.QuitBtnEvent(var Msg: TMessage);
begin
  CloseWindow
end;

{- Paint window contents }
procedure SCWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
var
  OldBrush, TheBrush: HBrush;
  I: Integer;

  procedure ShowSysColor(I: Integer);
  var
    SysColorBrush : HBrush;
    OldBrush: HBrush;
    SCName : PChar;
  begin
    with SysColorArray[I], SCRect do
    begin
      SysColorBrush := CreateSolidBrush(CurrentColor);
      OldBrush := SelectObject(PaintDC, SysColorBrush);
      Rectangle(PaintDC, Left, Top, Right, Bottom);
      SelectObject(PaintDC, OldBrush);
      DeleteObject(SysColorBrush);
      SCName := SysColorNames[I];
      TextOut(PaintDC, Left - 125, Top, SCName, StrLen(SCName))
    end
  end;

begin
  TheBrush := CreateSolidBrush(SampleColor);
  OldBrush := SelectObject(PaintDC, TheBrush);
  with SampleRect do Rectangle(PaintDC, Left, Top, Right, Bottom);
  SelectObject(PaintDC, OldBrush);
  DeleteObject(TheBrush);
  for I := 0 to color_EndColors do
    ShowSysColor(I)
end;

var

  SCApp: SCApplication;

begin
  SCApp.Init(app_Name);
  SCApp.Run;
  SCApp.Done
end.


{ --------------------------------------------------------------
  Copyright (c) 1991 by Tom Swan. All rights reserved.
  Revision 1.00    Date: 2/1/1991
  Revision 1.01    Date: 2/27/1991
  1. Changed all cm_Exit constants to cm_Quit
  2. Changed all CMExit procedure names to CMQuit
  3. Added length argument to all TStatic object inits
  Revision 1.02    Date: 5/11/1991
  1. Changed all PostQuitMessage calls to CloseWindow
  2. Added TColorScrollBar object
  3. Enabled (limited) keyboard use of controls
  4. Added hot key letters to buttons
  5. Moved most string constants to string table resource
  ------------------------------------------------------------- }